PC go! 2008 April/PCgo 2008-04 (DVD).iso/interface/contents/demoversionen_3846/13664/files/Data1.cab/coordtext.cls

Visual Basic class definition | 2004-03-05 | 12.5 KB | 397 lines

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "Coordinate"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True

Option Explicit
'/******************************************************************/
'/*                                                                */
'/*                      TurboCAD for Windows                      */
'/*                   Copyright (c) 1993 - 2001                    */
'/*             International Microcomputer Software, Inc.         */
'/*                            (IMSI)                              */
'/*                      All rights reserved.                      */
'/*                                                                */
'/******************************************************************/

'DBAPI constants
Const gkGraphic = 11
Const gkArc = 2
Const gkText = 6
Const gfCosmetic = 128&

'Stock property pages
Const ppStockPen = 1
Const ppStockBrush = 2
Const ppStockText = 4
Const ppStockInsert = 8
Const ppStockViewport = 16
Const ppStockAuto = 32

'Real variant types!
Const typeEmpty = 0
Const typeInteger = 2
Const typeLong = 3
Const typeSingle = 4
Const typeDouble = 5
Const typeCurrency = 6
Const typeDate = 7
Const typeString = 8
Const typeObject = 9
Const typeBoolean = 11
Const typeVariant = 12
Const typeIntegerEnum = typeInteger + 100
Const typeLongEnum = typeLong + 100
Const typeStringEnum = typeString + 100

'Property Ids
Const idCoordStyle = 1
Const idTextHeight = 2
Const idMarkSize = 3


'Property enums
Const NUM_TYPES = 3
Const dotted = 0
Const stacked = 1
Const cartesian = 2


'Number of properties, pages, wizards
Const NUM_PROPERTIES = 3
Const NUM_PAGES = 1
Const NUM_WIZARDS = 0
Const formCaption = "Coordinate Text"

Private Sub Class_Initialize()
    'Initialize class variables
End Sub

'Returns the user-visible description of this RegenMethod
Public Property Get Description() As String
    Description = "SDK Coordinate Text"
End Property

'Returns the persistent class id for this RegenMethod's property section
Public Property Get ClassID() As String
    ClassID = "{1B91F522-8900-11d0-AFFD-444553540000}"
End Property

'Retrieve types and names
Public Function GetPropertyInfo(Names As Variant, Types As Variant, IDs As Variant, Defaults As Variant) As Long
    ReDim Names(NUM_PROPERTIES), Types(NUM_PROPERTIES), IDs(NUM_PROPERTIES), Defaults(NUM_PROPERTIES)

    Names(0) = "CoordType"
    Types(0) = typeLong
    IDs(0) = idCoordStyle
    Defaults(0) = dotted

    Names(1) = "TextHeight"
    Types(1) = typeDouble
    IDs(1) = idTextHeight
    Defaults(1) = 0.3

    Names(2) = "MarkSize"
    Types(2) = typeDouble
    IDs(2) = idMarkSize
    Defaults(2) = 0.05

    GetPropertyInfo = NUM_PROPERTIES
End Function

'Get the number of property pages supporting this RegenMethod
Public Function GetPageInfo(ByVal AGraphic As Object, StockPages As Long, Names As Variant) As Long
    ReDim Names(NUM_PAGES)

    'Need the form
''    Load frmCoordText
''    Names(0) = frmCoordText.Caption
''    Unload frmCoordText
    Names(0) = formCaption
    'Set up which property pages we want to see
    StockPages = ppStockPen + ppStockAuto

    GetPageInfo = NUM_PAGES
End Function

Public Function GetWizardInfo(Names As Variant) As Long
    ReDim Names(NUM_WIZARDS)
    GetWizardInfo = NUM_WIZARDS
End Function

'Enumerate the names and values of a specified property
Public Function GetEnumNames(ByVal PropID As Long, Names As Variant, Values As Variant) As Long
    If PropID = idCoordStyle Then
        ReDim Names(NUM_TYPES), Values(NUM_TYPES)
        Names(0) = "Dotted"
        Values(0) = dotted
        Names(1) = "Stacked"
        Values(1) = stacked
        Names(2) = "Cartesian"
        Values(2) = cartesian
        GetEnumNames = NUM_TYPES
    Else
        GetEnumNames = 0
    End If
End Function

Public Function PageControls(ByVal ThisRegenMethod As Object, ByVal Graphic1 As Object, ByVal PageNumber As Long, ByVal SaveProperties As Boolean) As Boolean
        On Error GoTo Failed
Dim Graphic As Graphic
    Set Graphic = Graphic1
        Dim i%
        If ThisRegenMethod.Name <> Graphic.Type And Graphic.Type <> "GRAPHIC" Then Exit Function
        If SaveProperties Then
           With frmCoordText
                'When the property page is closed,
                'Get properties from the property pages

                For i% = 0 To NUM_TYPES
                    If .CoordType(i%).Value Then
                        Graphic.Properties("CoordType") = i%
                        Exit For
                    End If
                Next i%

                Graphic.Properties("MarkSize") = CDbl(.MarkSize.Text)
                Graphic.Properties("TextHeight") = CDbl(.TxtHeight.Text)

            End With
        Else
            'Property page is about to be opened
            'Make sure the form is loaded
            Load frmCoordText
            With frmCoordText
                'When the property page is opening,

                Dim CoordProp As Variant

                'If more than one CoordText shape is selected and they
                'do not have the same properties, don't set up this field
                On Error GoTo NoCType
                CoordProp = Graphic.Properties("CoordType")
                If VarType(CoordProp) <> vbEmpty Then
                       i% = CInt(CoordProp)
                       .CoordType(i%).Value = True
                End If
NoCType:
                'If we don't have the same marker size, skip setting up this
                'field also
                On Error GoTo NoMType
                .MarkSize.Text = Graphic.Properties("MarkSize")

NoMType:
                'If we don't have the same text size, skipp setting up
                'this field
                On Error GoTo NoTType
                .TxtHeight.Text = Graphic.Properties("TextHeight")

NoTType:
            End With
        End If


        PageControls = True
        Exit Function

Failed:
        PageControls = False
End Function

Public Function PageDone(ByVal ThisRegenMethod As Object, Optional PageNumber As Variant)
        'Done with form
        Unload frmCoordText
End Function

Public Function PropertyPages(ByVal ThisRegenMethod As Object, Optional PageNumber As Variant) As Boolean
    With frmCoordText
        .Show vbModal
        PropertyPages = Not .DialogCanceled
    End With
End Function

Public Function Wizard(ByVal ThisRegenMethod As Object, Optional WizardNumber As Variant) As Boolean
    Wizard = False
End Function

'Called when vertex has been moved, or other geometry change
Public Function OnGeometryChanged(ByVal Graphic As Object, ByVal GeomID As Long, paramOld As Variant, paramNew As Variant)
    'Regen Graphic
End Function

'Called when vertex is moved, or other geometry change
Public Function OnGeometryChanging(ByVal Graphic As Object, ByVal GeomID As Long, paramOld As Variant, paramNew As Variant) As Boolean
    'OK to continue with change
    OnGeometryChanging = True
End Function

Public Function OnNewGraphic(ByVal grfThis As Object, ByVal boolCopy As Boolean) As Boolean
    If boolCopy Then
        'Vertices are already added for us...
        OnNewGraphic = True
        Exit Function
    End If

    On Error GoTo Failed
    'New Graphic being created
    'X, Y, Z, PenDown, Selectable, Snappable, Editable, Linkable

    'First Vertex - "left bottom" - v0
    grfThis.Vertices.Add 0#, 0#, 0#, False, True, True, True, False

    'Limit the number of vertices allowed with this Smart Object
    grfThis.Properties("LimitVertices") = True

    OnNewGraphic = True
    Exit Function

Failed:
    'Return false on failure
    OnNewGraphic = False
End Function

'Function called whenever a copy of a graphic is being made
Public Function OnCopyGraphic(ByVal grfCopy As Object, ByVal grfSource As Object) As Boolean
    'Return false on failure
    OnCopyGraphic = True
End Function

'Notification function called after graphic property is saved
Public Function OnPropertyChanged(ByVal Graphic As Object, ByVal PropID As Long, _
        ValueOld As Variant, ValueNew As Variant)
    'Regen Graphic
End Function

'Notification function called when graphic property is saved
Public Function OnPropertyChanging(ByVal Graphic As Object, ByVal PropID As Long, _
        ValueOld As Variant, ValueNew As Variant) As Boolean
    'OK to proceed
    OnPropertyChanging = True
End Function

'Notification function called when graphic property is retrieved
Public Function OnPropertyGet(ByVal Graphic As Object, ByVal PropID As Long)
    'Do nothing
End Function


'Called when graphic's internal structure needs to be updated
Public Function Regen(ByVal grfThis1 As Object)
        'Setup error handler
        On Error Resume Next
        Err.Clear
Dim grfThis As Graphic
        Set grfThis = grfThis1
        'Set up lock
        Dim lockCount&
        lockCount& = grfThis.RegenLock

        'Setup error handler (make sure lock is removed)
        On Error GoTo FailedLock
        If lockCount& = 0 Then
            'Delete previous cosmetic children
            grfThis.Graphics.Clear gfCosmetic

            Dim Info As String
            Dim X As Double
            Dim Y As Double

            With grfThis.Vertices
                X = .Item(0).X
                Y = .Item(0).Y
            End With
            Dim dx As Double
            dx = grfThis.Properties("MarkSize")
            Dim dy As Double
            dy = dx
            Dim TSize As Double
            TSize = grfThis.Properties("TextHeight")

            Dim itype As Long
            Dim grfText As Object

            ' Make the Cross
            Dim grfLine As Object
            Set grfLine = grfThis.Graphics.AddLineSingle(X - dx, Y, 0, X + dx, Y, 0)
            grfLine.Cosmetic = True

            Set grfLine = grfThis.Graphics.AddLineSingle(X, Y + dy, 0, X, Y - dy, 0)
            grfLine.Cosmetic = True


            itype = grfThis.Properties("CoordType")

            ' Make the Text
            Select Case itype
                Case dotted
                    Info = Format(X, "0") & " "
                    Set grfText = grfThis.Graphics.AddText(Info, X, Y, 0, TSize, 0#)
                    grfText.Cosmetic = True

                    ' Move the X text left of the point by the width of the text
                    Dim mx As Double
                    With grfText.Vertices
                        mx = .Item(3).X - .Item(1).X
                        .Item(0).X = .Item(0).X - mx
                        .Item(1).X = .Item(1).X - mx
                        .Item(2).X = .Item(2).X - mx
                        .Item(3).X = .Item(3).X - mx
                        .Item(4).X = .Item(4).X - mx
                        .Item(5).X = .Item(5).X - mx
                    End With


                    Info = " " & Format(Y, "0")
                    Set grfText = grfThis.Graphics.AddText(Info, X, Y, 0, TSize, 0#)
                    grfText.Cosmetic = True


                Case stacked
                    Info = "X = " & Format(X, "0.00") & Chr(10) & "Y = " & Format(Y, "0.00")
                    Set grfText = grfThis.Graphics.AddText(Info, X, Y, 0, TSize * 2, 0#)

                    grfText.Cosmetic = True

                    ' Move the X text left of the point by the width of the text
                    Dim my As Double
                    With grfText.Vertices
                        my = (.Item(1).Y - .Item(2).Y) / 2#
                        .Item(0).Y = .Item(0).Y - my
                        .Item(1).Y = .Item(1).Y - my
                        .Item(2).Y = .Item(2).Y - my
                        .Item(3).Y = .Item(3).Y - my
                        .Item(4).Y = .Item(4).Y - my
                        .Item(5).Y = .Item(5).Y - my
                    End With
                Case cartesian
                    Info = "(" & Format(X, "0.00") & ", " & Format(Y, "0.00") & ")"
                    Set grfText = grfThis.Graphics.AddText(Info, X, Y, 0, TSize, 0#)
                    grfText.Cosmetic = True

            End Select

        End If

        'Remove lock
        grfThis.RegenUnlock

        Exit Function
FailedLock:
        'Remove lock
        grfThis.RegenUnlock

Failed:
End Function